home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume11 / templates / part04 < prev    next >
Encoding:
Internet Message Format  |  1987-10-04  |  50.0 KB
  1. Subject:  v11i094:  Template mode for GNU Emacs, Part04/06
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rs@uunet.UU.NET
  5.  
  6. Submitted-by: "Mark A. Ardis" <maa@sei.cmu.edu>
  7. Posting-number: Volume 11, Issue 94
  8. Archive-name: templates/part04
  9.  
  10. #! /bin/sh
  11. # This is a shell archive, meaning:
  12. # 1. Remove everything above the #! /bin/sh line.
  13. # 2. Save the resulting text in a file.
  14. # 3. Execute the file with /bin/sh (not csh) to create:
  15. #    tplparse.el
  16. #    tplscan.el
  17. export PATH; PATH=/bin:/usr/bin:$PATH
  18. echo shar: "extracting 'tplparse.el'" '(35827 characters)'
  19. if test -f 'tplparse.el'
  20. then
  21.     echo shar: "will not over-write existing file 'tplparse.el'"
  22. else
  23. sed 's/^X//' << \SHAR_EOF > 'tplparse.el'
  24. X;;; tplparse.el -- Parsing routines for template package
  25. X;;; Copyright (C) 1987 Mark A. Ardis.
  26. X
  27. X(require 'tplvars)
  28. X(require 'tplhelper)
  29. X
  30. X(provide 'tplparse)
  31. X
  32. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  33. X;;; All global variables are in "tplvars"
  34. X
  35. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  36. X
  37. X(defun looking-at-tpl ()
  38. X  "t if text after point matches specified template."
  39. X  (interactive)
  40. X                    ; Local Variables
  41. X  (let (name-list tpl-name)
  42. X                    ; Body
  43. X    (setq name-list (tpl-make-completion-list))
  44. X    (setq tpl-name (completing-read "looking-at-tpl: Template name? "
  45. X                    name-list nil t nil))
  46. X    (tpl-looking-at tpl-name)
  47. X  ) ; let
  48. X) ; defun looking-at-tpl
  49. X
  50. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  51. X
  52. X(defun query-replace-tpl ()
  53. X  "Replace some instances of a template with corresponding instances
  54. X   of another."
  55. X  (interactive)
  56. X                    ; Local Variables
  57. X  (let (name-list from to)
  58. X                    ; Body
  59. X    (setq name-list (tpl-make-completion-list))
  60. X    (setq from (completing-read "query-replace-tpl: From? "
  61. X                    name-list nil t nil))
  62. X    (setq to (completing-read (concat "query-replace-tpl: From " from " To? ")
  63. X                    name-list nil t nil))
  64. X    (tpl-query-replace from to)
  65. X  ) ; let
  66. X) ; defun query-replace-tpl
  67. X
  68. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  69. X
  70. X(defun replace-tpl ()
  71. X  "Replace an instance of a template with a corresponding instance
  72. X   of another template."
  73. X  (interactive)
  74. X                    ; Local Variables
  75. X  (let (name-list from to)
  76. X                    ; Body
  77. X    (setq name-list (tpl-make-completion-list))
  78. X    (setq from (completing-read "replace-tpl: From? "
  79. X                    name-list nil t nil))
  80. X    (setq to (completing-read (concat "replace-tpl: From " from " To? ")
  81. X                    name-list nil t nil))
  82. X    (while (tpl-search-forward from (point-max) t)
  83. X      (exchange-point-and-mark)
  84. X      (tpl-replace from to)
  85. X      ) ; while
  86. X  ) ; let
  87. X) ; defun replace-tpl
  88. X
  89. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  90. X
  91. X(defun search-forward-tpl ()
  92. X  "Search forward from point for a template."
  93. X  (interactive)
  94. X                    ; Local Variables
  95. X  (let (name-list tpl-name)
  96. X                    ; Body
  97. X    (setq name-list (tpl-make-completion-list))
  98. X    (setq tpl-name (completing-read "search-forward-tpl: Name of template? "
  99. X                    name-list nil t nil))
  100. X    (tpl-search-forward tpl-name)
  101. X  ) ; let
  102. X) ; defun search-forward-tpl
  103. X
  104. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  105. X
  106. X(defun tpl-delete-leading-whitespace (text-list)
  107. X  "Remove leading whitespace tokens from TEXT-LIST and return remaining list."
  108. X                    ; Local Variables
  109. X  (let ()
  110. X                    ; Body
  111. X    (while (and text-list (equal tpl-whitespace-type
  112. X                 (tpl-token-name (car text-list))))
  113. X      (setq text-list (cdr text-list))
  114. X      ) ; while
  115. X    ; return
  116. X    text-list
  117. X    ) ; let
  118. X  ) ; defun tpl-delete-leading-whitespace
  119. X
  120. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  121. X
  122. X(defun tpl-fix-match (tree old new)
  123. X  "Adjust indentation in TREE from OLD to NEW."
  124. X                    ; Local Variables
  125. X  (let (result token-list token)
  126. X                    ; Body
  127. X    (if (not new)
  128. X    (setq new old)
  129. X      ) ; if
  130. X    (setq result nil)
  131. X    (setq token-list (tpl-token-value tree))
  132. X    (while token-list
  133. X      (setq token (car token-list))
  134. X      (setq token-list (cdr token-list))
  135. X      ;(debug nil "token" token)
  136. X      (if (and (equal tpl-indentation-type (tpl-token-name token))
  137. X           (/= tpl-comment-level (tpl-token-value token)))
  138. X      (setq token (tpl-make-token (tpl-token-type token)
  139. X                      (tpl-token-name token)
  140. X                      (+ (- new old) (tpl-token-value token))))
  141. X    ) ; if
  142. X      (setq result (append result (list token)))
  143. X      ) ; while token-list
  144. X    ; return
  145. X    result
  146. X    ) ; let
  147. X  ) ; defun tpl-fix-match
  148. X
  149. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  150. X
  151. X(defun tpl-get-match (placeholder tree indent)
  152. X  "Find match for PLACEHOLDER in TREE.  Adjust matched value with INDENT."
  153. X                    ; Local Variables
  154. X  (let (name match token token-type current-indent)
  155. X                    ; Body
  156. X    (setq name (tpl-token-name (tpl-parse-placeholder (tpl-token-value placeholder))))
  157. X    (setq match nil)
  158. X    (while (and tree (not match))
  159. X      (setq token (car tree))
  160. X      (setq tree (cdr tree))
  161. X      (setq token-type (tpl-token-type token))
  162. X      ;(debug nil "token-type" token-type)
  163. X      (if (equal tpl-terminal-type token-type)
  164. X      (if (equal tpl-indentation-type (tpl-token-name token))
  165. X          (setq current-indent (tpl-token-value token))
  166. X        ) ; if (equal tpl-indentation-type (tpl-token-name token))
  167. X    ; else
  168. X    (if (equal name
  169. X           (tpl-token-name
  170. X            (tpl-parse-placeholder (tpl-token-name token))))
  171. X        (setq match (tpl-fix-match token indent current-indent))
  172. X      ) ; if (equal name...)
  173. X    ) ; if (equal tpl-terminal-type token-type)
  174. X      ) ; while (and tree (not match))
  175. X    ; return
  176. X    match
  177. X    ) ; let
  178. X  ) ; defun tpl-get-match
  179. X
  180. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  181. X
  182. X(defun tpl-get-placeholder-end (placeholder tpl-name &optional occurrence)
  183. X  "Prompt user for end of PLACEHOLDER in TPL-NAME.
  184. X   Optional third argument OCCURRENCE specifies which
  185. X   occurrence of placeholder to find."
  186. X                    ; Local Variables
  187. X  (let (template msg return stop size)
  188. X                    ; Body
  189. X    (if (not occurrence)
  190. X    (setq occurrence 1)
  191. X      ) ; if
  192. X                    ; Get value before changing buffer
  193. X    (setq template (tpl-find-template tpl-name))
  194. X    (save-window-excursion
  195. X      (delete-other-windows)
  196. X      (pop-to-buffer (get-buffer-create "*Template*"))
  197. X      (erase-buffer)
  198. X      (tpl-unscan template)
  199. X                    ; Size the window
  200. X      (setq stop (point-max))
  201. X      (goto-char (point-min))
  202. X      (setq size (1+ (count-lines (point) stop)))
  203. X      (setq size (max size window-min-height))
  204. X      (if (< size (window-height))
  205. X      (shrink-window (- (window-height) size))
  206. X    ) ; if
  207. X                    ; Find the placeholder
  208. X      (search-forward placeholder (point-max) t occurrence)
  209. X      (other-window 1)
  210. X      (setq msg (concat "In \"" tpl-name "\" looking for end of \""
  211. X            placeholder "\""))
  212. X      (setq return (tpl-get-position (point) (point-max) msg))
  213. X      ) ; save-window-excursion
  214. X    (bury-buffer "*Template*")
  215. X    return
  216. X  ) ; let
  217. X) ; defun tpl-get-placeholder-end
  218. X
  219. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  220. X
  221. X(defun tpl-get-position (start stop msg &optional start-pos narrow)
  222. X  "Prompt user for a location between START and STOP with MSG.
  223. X   Optional fourth argument START-POS may be used for initial
  224. X   placement of point.  Fifth argument NARROW, if non-nil,
  225. X   narrows the region."
  226. X                    ; Local Variables
  227. X  (let (looking was-modifiable)
  228. X                    ; Body
  229. X                    ; Check for valid region
  230. X    (if (< stop start)
  231. X    (error "tpl-get-position: Invalid region specification.")
  232. X      ) ; if
  233. X                    ; Save current status
  234. X    (if (not start-pos)
  235. X    (setq start-pos start)
  236. X      ) ; if
  237. X    (save-restriction
  238. X      (if narrow
  239. X      (narrow-to-region start stop)
  240. X    ) ; if
  241. X      (setq was-modifiable (not buffer-read-only))
  242. X      (if was-modifiable
  243. X      (toggle-read-only)
  244. X    ) ; if was-modifiable
  245. X      (setq orig-buffer (current-buffer))
  246. X                    ; Loop until acceptable answer
  247. X      (setq looking t)
  248. X      (while looking
  249. X    (goto-char start-pos)
  250. X    (message msg)
  251. X                    ; Wait for user selection
  252. X    (recursive-edit)
  253. X                    ; Check validity
  254. X    (if (or (not (equal orig-buffer (current-buffer)))
  255. X        (< (point) start)
  256. X        (> (point) stop))
  257. X        (progn
  258. X          (ding)
  259. X          (message "Selected position out of bounds.")
  260. X          (sit-for 2)
  261. X          (pop-to-buffer orig-buffer)
  262. X          (goto-char start-pos)
  263. X          ) ; progn
  264. X      ; else
  265. X      (setq looking nil)
  266. X      ) ; if
  267. X    ) ; while looking
  268. X                    ; Restore original status
  269. X      (if was-modifiable
  270. X      (toggle-read-only)
  271. X    ) ; if was-modifiable
  272. X      (if narrow
  273. X      (widen)
  274. X    ) ; if narrow
  275. X      ) ; save-restriction
  276. X    (point)                ; return
  277. X  ) ; let
  278. X) ; defun tpl-get-position
  279. X
  280. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  281. X
  282. X(defun tpl-leading-text (template)
  283. X  "Return literal text string at start of TEMPLATE (a name)."
  284. X                    ; Local Variables
  285. X  (let (body start stop result)
  286. X                    ; Body
  287. X    (setq body (tpl-find-template template))
  288. X    (if (not body)
  289. X    (error "Cannot find template.")
  290. X      ) ; if (not body)
  291. X    (get-buffer-create "*Work*")
  292. X    (save-window-excursion
  293. X      (set-buffer "*Work*")
  294. X      (erase-buffer)
  295. X      (tpl-unscan body)
  296. X      (goto-char (point-min))
  297. X      (setq start (point))
  298. X      (end-of-line nil)
  299. X      (setq stop (point))
  300. X      (goto-char start)
  301. X      (if (re-search-forward tpl-begin-placeholder stop start)
  302. X      (re-search-backward tpl-begin-placeholder)
  303. X    ) ; if
  304. X      (setq result (buffer-substring start (point)))
  305. X      ) ; save-window-excursion
  306. X    ; return
  307. X    result
  308. X    ) ; let
  309. X  ) ; defun tpl-leading-text
  310. X
  311. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  312. X
  313. X(defun tpl-line-to-token (tree)
  314. X  "Convert TREE from line-format to token-format."
  315. X                    ; Local Variables
  316. X  (let (line-list line token result type name)
  317. X                    ; Body
  318. X    (setq result nil)
  319. X    (setq type (tpl-token-type tree))
  320. X    (setq name (tpl-token-name tree))
  321. X    (setq line-list (tpl-token-value tree))
  322. X    (while line-list
  323. X      (setq line (car line-list))
  324. X      (setq line-list (cdr line-list))
  325. X      (setq result
  326. X        (append result
  327. X            (list (tpl-make-token tpl-terminal-type
  328. X                      tpl-indentation-type
  329. X                      (tpl-line-indent line)))))
  330. X      (setq result (append result (tpl-line-tokens line)))
  331. X      (if line-list
  332. X      (setq result (append result (list tpl-newline-token)))
  333. X    ) ; if line-list
  334. X      ) ; while line-list
  335. X    (setq result (tpl-make-token type name result))
  336. X    ; return
  337. X    result
  338. X    ) ; let
  339. X  ) ; defun tpl-line-to-token
  340. X
  341. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  342. X
  343. X(defun tpl-looking-at (name)
  344. X  "t if text after point matches template NAME"
  345. X                    ; Local Variables
  346. X  (let (result)
  347. X                    ; Body
  348. X    (setq result (tpl-match-template name))
  349. X    (if result
  350. X    t
  351. X      nil
  352. X      ) ; if
  353. X    ) ; let
  354. X  ) ; defun tpl-looking-at
  355. X
  356. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  357. X
  358. X(defun tpl-match-function-template (template)
  359. X  "Match TEMPLATE and return t or nil."
  360. X                    ; Local Variables
  361. X  (let ()
  362. X                    ; Body
  363. X    (error "tpl-match-function-type: Cannot match function-type templates.")
  364. X    ) ; let
  365. X  ) ; defun tpl-match-function-template
  366. X
  367. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  368. X
  369. X(defun tpl-match-lexical-template (template)
  370. X  "Match TEMPLATE and return t or nil."
  371. X                    ; Local Variables
  372. X  (let ()
  373. X                    ; Body
  374. X    (looking-at (tpl-token-value template))
  375. X    ) ; let
  376. X  ) ; defun tpl-match-lexical-template
  377. X
  378. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  379. X
  380. X(defun tpl-match-line (pattern text)
  381. X  "Attempt to match the line described by PATTERN with TEXT. Return t or nil."
  382. X                    ; Local Variables
  383. X  (let (pattern-list text-list next-pattern result success)
  384. X                    ; Body
  385. X    (if (and text
  386. X         (= (tpl-line-indent pattern) (tpl-line-indent text)))
  387. X    (progn
  388. X      (setq success t)
  389. X      (setq pattern-list (tpl-line-tokens pattern))
  390. X      (setq text-list (tpl-line-tokens text))
  391. X      (while (and pattern-list success text-list)
  392. X        (setq next-pattern (car pattern-list))
  393. X        (setq pattern-list (cdr pattern-list))
  394. X        (setq result (tpl-match-token next-pattern text-list))
  395. X        (if result
  396. X        (setq text-list (cdr result))
  397. X          ; else
  398. X          (setq success nil)
  399. X          ) ; if result
  400. X        ) ; while pattern-list
  401. X      ) ; progn
  402. X      ; else
  403. X      (setq success nil)
  404. X      ) ; if (= (tpl-line-indent pattern) (tpl-line-indent text))
  405. X    ; return
  406. X    success
  407. X    ) ; let
  408. X  ) ; defun tpl-match-line
  409. X
  410. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  411. X
  412. X(defun tpl-match-pattern (pattern-list scanner-patterns)
  413. X  "Attempt to match each line in PATTERN-LIST with text after point.
  414. X    Return a list of matches.  Second argument SCANNER-PATTERNS
  415. X    specifies what type of lexical patterns to use when scanning."
  416. X                    ; Local Variables
  417. X  (let (success tree this-pattern next-pattern this-match first-text next-text
  418. X        start-region start-col
  419. X        this-indent next-indent)
  420. X                    ; Body
  421. X    (setq success t)
  422. X    (setq tree nil)
  423. X                    ; Initialize scanner
  424. X    (setq start-region (point))
  425. X    (setq start-col (current-column))
  426. X    (setq this-indent 0)
  427. X                    ; Get first "next text line"
  428. X    (back-to-indentation)
  429. X    (setq next-text (tpl-scan-line start-col scanner-patterns))
  430. X    (setq this-indent (tpl-line-indent next-text))
  431. X    (if (not (eobp))
  432. X    (forward-char)
  433. X      ) ; if
  434. X                    ; For each line in pattern
  435. X    (while (and pattern-list success)
  436. X      ;(debug nil "top of pattern loop")
  437. X                    ; Get next pattern line
  438. X      (setq this-pattern (car pattern-list))
  439. X      (setq pattern-list (cdr pattern-list))
  440. X      (if pattern-list
  441. X      (setq next-pattern (car pattern-list))
  442. X    ; else
  443. X    (setq next-pattern nil)
  444. X    ) ; if pattern-list
  445. X      (setq this-match nil)
  446. X                    ; Get first text line
  447. X      (setq first-text next-text)
  448. X                    ; Try to match lines
  449. X      (if (tpl-match-line this-pattern first-text)
  450. X      (progn
  451. X        (setq this-match (list first-text))
  452. X        (if next-pattern
  453. X        (progn
  454. X          (setq next-indent (tpl-line-indent next-pattern))
  455. X                    ; Get next text line
  456. X          (back-to-indentation)
  457. X          (setq next-text (tpl-scan-line start-col scanner-patterns))
  458. X          (setq this-indent (tpl-line-indent next-text))
  459. X          (if (not (eobp))
  460. X              (forward-char)
  461. X            ) ; if
  462. X                    ; Append until next match
  463. X          (while (and (not (eobp))
  464. X                  (or (> this-indent next-indent)
  465. X                  (equal (tpl-line-tokens next-text) nil)))
  466. X            ;(debug nil "appending in middle...")
  467. X            (setq this-match (append this-match (list next-text)))
  468. X                    ; Get next text line
  469. X            (back-to-indentation)
  470. X            (setq next-text (tpl-scan-line start-col scanner-patterns))
  471. X            (setq this-indent (tpl-line-indent next-text))
  472. X            (if (not (eobp))
  473. X            (forward-char)
  474. X              ) ; if
  475. X            ) ; while
  476. X          ) ; progn
  477. X          ; else
  478. X                    ; Append until no more indentation
  479. X          (progn
  480. X        (while (and (not (eobp))
  481. X                (or (> this-indent 0)
  482. X                (equal (tpl-line-tokens next-text) nil)))
  483. X          ;(debug nil "appending at end...")
  484. X          (setq this-match (append this-match (list next-text)))
  485. X                    ; Get next text line
  486. X          (back-to-indentation)
  487. X          (setq this-col (current-column))
  488. X          (setq next-text (tpl-scan-line start-col scanner-patterns))
  489. X          (setq this-indent (tpl-line-indent next-text))
  490. X          (if (not (eobp))
  491. X              (forward-char)
  492. X            ) ; if
  493. X          ) ; while
  494. X        (if (> this-indent 0)
  495. X            (setq this-match (append this-match (list next-text)))
  496. X          (forward-line -1)
  497. X          ) ; if
  498. X        ) ; progn
  499. X          ) ; if next-pattern
  500. X        (setq tree (append tree (list (list this-pattern this-match))))
  501. X        ) ; progn
  502. X    ; else
  503. X    (setq success nil)
  504. X    ) ; if (tpl-match-line this-pattern first-text)
  505. X      ) ; while pattern-list
  506. X    ; Set point and mark
  507. X    (if success
  508. X    (progn
  509. X      (setq success tree)
  510. X      (set-mark start-region)
  511. X      (if (eobp)
  512. X          (end-of-line)
  513. X        ; else
  514. X        (end-of-line 0)
  515. X        ) ; if
  516. X      ) ; progn
  517. X      ; else
  518. X      (goto-char start-region)
  519. X      ) ; if success
  520. X    ; return
  521. X    success
  522. X    ) ; let
  523. X  ) ; defun tpl-match-pattern
  524. X
  525. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  526. X
  527. X(defun tpl-match-repetition-template (template)
  528. X  "Match TEMPLATE and return t or nil."
  529. X                    ; Local Variables
  530. X  (let ()
  531. X                    ; Body
  532. X    (error
  533. X     "tpl-match-repetition-template: Cannot match repetition-type template.")
  534. X    ) ; let
  535. X  ) ; defun tpl-match-repetition-template
  536. X
  537. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  538. X
  539. X(defun tpl-match-selection-template (template)
  540. X  "Match TEMPLATE and return tree or nil."
  541. X                    ; Local Variables
  542. X  (let (result selection-list selection)
  543. X                    ; Body
  544. X    (setq result nil)
  545. X    (setq selection-list (tpl-token-value template))
  546. X    (while (and selection-list (not result))
  547. X      (setq selection (car selection-list))
  548. X      (setq selection-list (cdr selection-list))
  549. X      (setq selection (tpl-token-value (car (tpl-line-tokens selection))))
  550. X      (setq result (tpl-match-template selection))
  551. X      ) ; while selection-list
  552. X    ; return
  553. X    result
  554. X    ) ; let
  555. X  ) ; defun tpl-match-selection-template
  556. X
  557. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  558. X
  559. X(defun tpl-match-sequence-template (template)
  560. X  "Match TEMPLATE and return tree or nil."
  561. X                    ; Local Variables
  562. X  (let (pattern-list result)
  563. X                    ; Body
  564. X    (setq pattern-list (tpl-token-value template))
  565. X    (setq result (tpl-match-pattern pattern-list lex-patterns))
  566. X    (if result
  567. X    (setq result (tpl-make-token
  568. X              tpl-sequence-type (tpl-token-name template) result))
  569. X      ) ; if result
  570. X    ; return
  571. X    result
  572. X    ) ; let
  573. X  ) ; defun tpl-match-sequence-template
  574. X
  575. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  576. X
  577. X(defun tpl-match-string-template (template)
  578. X  "Match TEMPLATE and return tree or nil."
  579. X                    ; Local Variables
  580. X  (let (pattern-list result)
  581. X                    ; Body
  582. X    (setq pattern-list (tpl-token-value template))
  583. X    (setq result (tpl-match-pattern pattern-list string-patterns))
  584. X    (if result
  585. X    (setq result (tpl-make-token
  586. X              tpl-sequence-type (tpl-token-name template) result))
  587. X      ) ; if result
  588. X    ; return
  589. X    result
  590. X    ) ; let
  591. X  ) ; defun tpl-match-string-template
  592. X
  593. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  594. X
  595. X(defun tpl-match-template (name)
  596. X  "Match template NAME and return tree or nil."
  597. X                    ; Local Variables
  598. X  (let (template template-type result)
  599. X                    ; Body
  600. X    (setq template (tpl-find-template name))
  601. X    (setq template-type (tpl-token-type template))
  602. X    (cond
  603. X     ((equal template-type tpl-function-type)
  604. X      (setq result (tpl-match-function-template template))
  605. X      ) ; (equal template-type tpl-function-type)
  606. X     ((equal template-type tpl-lexical-type)
  607. X      (setq result (tpl-match-lexical-template template))
  608. X      ) ; (equal template-type tpl-lexical-type)
  609. X     ((equal template-type tpl-repetition-type)
  610. X      (setq result (tpl-match-repetition-template template))
  611. X      ) ; (equal template-type tpl-repetition-type)
  612. X     ((equal template-type tpl-selection-type)
  613. X      (setq result (tpl-match-selection-template template))
  614. X      ) ; (equal template-type tpl-selection-type)
  615. X     ((equal template-type tpl-sequence-type)
  616. X      (setq result (tpl-match-sequence-template template))
  617. X      ) ; (equal template-type tpl-sequence-type)
  618. X     ((equal template-type tpl-string-type)
  619. X      (setq result (tpl-match-string-template template))
  620. X      ) ; (equal template-type tpl-string-type)
  621. X     ) ; cond
  622. X    ; return
  623. X    result
  624. X    ) ; let
  625. X  ) ; defun tpl-match-template
  626. X
  627. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  628. X
  629. X(defun tpl-match-token (token text-list)
  630. X  "Attempt to match TOKEN with tokens in TEXT-LIST.  Return the
  631. X    list (t remainder-of-TEXT-LIST) or nil."
  632. X                    ; Local Variables
  633. X  (let (type success)
  634. X                    ; Body
  635. X    (setq text-list (tpl-delete-leading-whitespace text-list))
  636. X    (setq type (tpl-token-name token))
  637. X    (cond
  638. X     ((or (equal type tpl-other-type)
  639. X      (equal type tpl-punctuation-type)
  640. X      (equal type tpl-string-type))
  641. X      (progn
  642. X    (if text-list
  643. X        (progn
  644. X          (setq success (equal (tpl-token-value token)
  645. X                   (tpl-token-value (car text-list))))
  646. X          (setq text-list (cdr text-list))
  647. X          ) ; progn
  648. X      ; else
  649. X      (setq success nil)
  650. X      ) ; if text-list
  651. X    ) ; progn
  652. X      ) ; (or (equal type tpl-other-type)...)
  653. X     ((equal type tpl-word-type)
  654. X      (progn
  655. X    (if text-list
  656. X        (progn
  657. X          (setq success (equal (upcase (tpl-token-value token))
  658. X                   (upcase (tpl-token-value (car text-list)))))
  659. X          (setq text-list (cdr text-list))
  660. X          ) ; progn
  661. X      ; else
  662. X      (setq success nil)
  663. X      ) ; if text-list
  664. X    ) ; progn
  665. X      ) ; (equal type tpl-word-type)
  666. X     ((equal type tpl-whitespace-type)
  667. X      (progn
  668. X    (if (and text-list
  669. X         (equal tpl-whitespace-type (tpl-token-name (car text-list))))
  670. X        (setq text-list (cdr text-list))
  671. X      ) ; if
  672. X    (setq success t)
  673. X    ) ; progn
  674. X      ) ; (equal type tpl-whitespace-type)
  675. X     ((or (equal type tpl-placeholder-type)
  676. X      (equal type tpl-optional-type))
  677. X      (progn
  678. X    (setq text-list nil)
  679. X    (setq success t)
  680. X    ) ; progn
  681. X      ) ; (equal type tpl-placeholder-type)
  682. X     ) ; cond
  683. X    (if success
  684. X    (setq success (cons t text-list))
  685. X      ) ; if success
  686. X    ; return
  687. X    success
  688. X    ) ; let
  689. X  ) ; defun tpl-match-token
  690. X
  691. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  692. X
  693. X(defun tpl-parse-function (template)
  694. X  "Try to parse text at point as an instance of function-type TEMPLATE.
  695. X   Return a parse tree or nil."
  696. X                    ; Local Variables
  697. X  (let ()
  698. X                    ; Body
  699. X    (error "tpl-parse-function: Cannot parse function-type templates.")
  700. X  ) ; let
  701. X) ; defun tpl-parse-function
  702. X
  703. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  704. X
  705. X(defun tpl-parse-instance (tpl-name)
  706. X  "Try to parse text at point as an instance of TPL-NAME.
  707. X   Return a parse tree or nil."
  708. X                    ; Local Variables
  709. X  (let ()
  710. X                    ; Body
  711. X    (setq template (tpl-find-template tpl-name))
  712. X    (setq template-type (tpl-token-type template))
  713. X    (cond
  714. X      ((equal template-type tpl-function-type)
  715. X    (setq result (tpl-parse-function template))
  716. X      ) ; (equal template-type tpl-function-type)
  717. X      ((equal template-type tpl-lexical-type)
  718. X    (setq result (tpl-parse-lexical template))
  719. X      ) ; (equal template-type tpl-lexical-type)
  720. X      ((equal template-type tpl-repetition-type)
  721. X    (setq result (tpl-parse-repetition template))
  722. X      ) ; (equal template-type tpl-repetition-type)
  723. X      ((equal template-type tpl-selection-type)
  724. X    (setq result (tpl-parse-selection template))
  725. X      ) ; (equal template-type tpl-selection-type)
  726. X      ((equal template-type tpl-sequence-type)
  727. X    (setq result (tpl-parse-sequence template))
  728. X      ) ; (equal template-type tpl-sequence-type)
  729. X      ((equal template-type tpl-string-type)
  730. X    (setq result (tpl-parse-string template))
  731. X      ) ; (equal template-type tpl-string-type)
  732. X    ) ; cond
  733. X    result                ; return
  734. X  ) ; let
  735. X) ; defun tpl-parse-instance
  736. X
  737. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  738. X
  739. X(defun tpl-parse-lexical (template)
  740. X  "Try to parse text at point as an instance of lexical-type TEMPLATE.
  741. X   Return a parse tree or nil."
  742. X                    ; Local Variables
  743. X  (let ()
  744. X                    ; Body
  745. X    (error "tpl-parse-lexical: Cannot parse lexical-type templates.")
  746. X  ) ; let
  747. X) ; defun tpl-parse-lexical
  748. X
  749. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  750. X
  751. X(defun tpl-parse-pattern (pattern tpl-name start-col scanner-patterns)
  752. X  "Try to parse text at point as an instance of PATTERN within
  753. X   template TPL-NAME.  START-COL specifies the starting column of
  754. X   the template.  SCANNER-PATTERNS specifies which lexical patterns
  755. X   to use when scanning.  Return a token or nil."
  756. X                    ; Local Variables
  757. X  (let (type result start stop this-col indent-level)
  758. X                    ; Body
  759. X    (setq type (tpl-token-name pattern))
  760. X    (cond
  761. X      ((equal type tpl-indentation-type)
  762. X    (progn
  763. X      (setq result pattern)
  764. X      ) ; progn
  765. X      ) ; (equal type tpl-indentation-type)
  766. X      ((equal type tpl-newline-type)
  767. X    (progn
  768. X      (setq result pattern)
  769. X      ) ; progn
  770. X      ) ; (equal type tpl-newline-type)
  771. X      ((equal type tpl-other-type)
  772. X    (progn
  773. X      (tpl-skip-over-whitespace)
  774. X      (if (looking-at (tpl-token-value pattern))
  775. X          (setq result (tpl-scan-token scanner-patterns))
  776. X        (setq result nil)
  777. X        ) ; if
  778. X      ) ; progn
  779. X      ) ; (equal type tpl-other-type)
  780. X      ((equal type tpl-placeholder-type)
  781. X    (progn
  782. X      (tpl-skip-over-whitespace)
  783. X      (setq start (point))
  784. X      (setq stop (tpl-get-placeholder-end (tpl-token-value pattern)
  785. X                          tpl-name))
  786. X      (setq result nil)
  787. X      (goto-char start)
  788. X      (while (< (point) stop)
  789. X        (if (eolp)
  790. X                    ; This code duplicates some of
  791. X                    ;   "tpl-scan-line"
  792. X        (progn
  793. X          (setq result
  794. X            (append result (list tpl-newline-token)))
  795. X          (forward-line 1)
  796. X          (back-to-indentation)
  797. X          (setq this-col (current-column))
  798. X          (cond
  799. X           ((>= this-col comment-column)
  800. X            (progn
  801. X              (setq indent-level tpl-comment-level)
  802. X              ) ; progn
  803. X            ) ; comment
  804. X           ((<= this-col start-col)
  805. X            (progn
  806. X              (setq indent-level 0)
  807. X              ) ; progn
  808. X            ) ; too small
  809. X           (t
  810. X            (progn
  811. X              (setq indent-level (- this-col start-col))
  812. X              ) ; progn
  813. X            ) ; t
  814. X           ) ; cond
  815. X          (setq result
  816. X            (append result (list (tpl-make-token
  817. X                          tpl-terminal-type
  818. X                          tpl-indentation-type
  819. X                          indent-level))))
  820. X          ) ; progn
  821. X          ; else
  822. X          (progn
  823. X        (setq result
  824. X              (append result (list (tpl-scan-token scanner-patterns))))
  825. X        ) ; progn
  826. X          ) ; if
  827. X        ) ; while
  828. X      (setq result (tpl-make-token tpl-placeholder-type
  829. X                   (tpl-token-value pattern)
  830. X                   result))
  831. X      ) ; progn
  832. X      ) ; (equal type tpl-placeholder-type)
  833. X      ((equal type tpl-punctuation-type)
  834. X    (progn
  835. X      (tpl-skip-over-whitespace)
  836. X      (if (looking-at (tpl-token-value pattern))
  837. X          (setq result (tpl-scan-token scanner-patterns))
  838. X        (setq result nil)
  839. X        ) ; if
  840. X      ) ; progn
  841. X      ) ; (equal type tpl-punctuation-type)
  842. X      ((equal type tpl-string-type)
  843. X    (progn
  844. X      (tpl-skip-over-whitespace)
  845. X      (if (looking-at (tpl-token-value pattern))
  846. X          (setq result (tpl-scan-token scanner-patterns))
  847. X        (setq result nil)
  848. X        ) ; if
  849. X      ) ; progn
  850. X      ) ; (equal type tpl-string-type)
  851. X      ((equal type tpl-whitespace-type)
  852. X    (progn
  853. X      (setq result pattern)
  854. X      ) ; progn
  855. X      ) ; (equal type tpl-whitespace-type)
  856. X      ((equal type tpl-word-type)
  857. X    (progn
  858. X      (tpl-skip-over-whitespace)
  859. X      (if (looking-at (tpl-token-value pattern))
  860. X          (setq result (tpl-scan-token scanner-patterns))
  861. X        (setq result nil)
  862. X        ) ; if
  863. X      ) ; progn
  864. X      ) ; (equal type tpl-word-type)
  865. X    ) ; cond
  866. X    result                ; return
  867. X  ) ; let
  868. X) ; defun tpl-parse-pattern
  869. X
  870. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  871. X
  872. X(defun tpl-parse-placeholder (string)
  873. X  "Parse STRING as a placeholder and return token."
  874. X                    ; Local Variables
  875. X  (let (token)
  876. X                    ; Body
  877. X    (get-buffer-create "*Work*")
  878. X    (save-window-excursion
  879. X      (set-buffer "*Work*")
  880. X      (erase-buffer)
  881. X      (insert string)
  882. X      (beginning-of-line)
  883. X      (setq token (tpl-scan-placeholder))
  884. X      ) ; save-window-excursion
  885. X    ; return
  886. X    token
  887. X    ) ; let
  888. X  ) ; defun tpl-parse-placeholder
  889. X
  890. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  891. X
  892. X(defun tpl-parse-repetition (template)
  893. X  "Try to parse text at point as an instance of repetition-type TEMPLATE.
  894. X   Return a parse tree or nil."
  895. X                    ; Local Variables
  896. X  (let ()
  897. X                    ; Body
  898. X    (error "tpl-parse-repetition: Cannot parse repetition-type templates.")
  899. X  ) ; let
  900. X) ; defun tpl-parse-repetition
  901. X
  902. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  903. X
  904. X(defun tpl-parse-selection (template)
  905. X  "Try to parse text at point as an instance of selection-type TEMPLATE.
  906. X   Return a parse tree or nil."
  907. X                    ; Local Variables
  908. X  (let ()
  909. X                    ; Body
  910. X    (error "tpl-parse-selection: Cannot parse selection-type templates.")
  911. X  ) ; let
  912. X) ; defun tpl-parse-selection
  913. X
  914. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  915. X
  916. X(defun tpl-parse-sequence (template)
  917. X  "Try to parse text at point as an instance of sequence-type TEMPLATE.
  918. X   Return a parse tree or nil."
  919. X                    ; Local Variables
  920. X  (let (tpl-name pattern-list pattern result success match start-col)
  921. X                    ; Body
  922. X    (setq tpl-name (tpl-token-name template))
  923. X    (setq pattern-list (tpl-token-value (tpl-line-to-token template)))
  924. X    (setq start-col (current-column))
  925. X    (setq result nil)
  926. X    (setq success t)
  927. X    (while (and success pattern-list)
  928. X      (setq pattern (car pattern-list))
  929. X      (setq pattern-list (cdr pattern-list))
  930. X      (setq match (tpl-parse-pattern pattern tpl-name start-col lex-patterns))
  931. X      (if match
  932. X      (setq result (append result (list match)))
  933. X    ; else
  934. X    (setq success nil)
  935. X    ) ; if match
  936. X      ) ; while
  937. X    (if success
  938. X    result                ; return
  939. X      ; else
  940. X      nil                ; return
  941. X      ) ; if success
  942. X  ) ; let
  943. X) ; defun tpl-parse-sequence
  944. X
  945. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  946. X
  947. X(defun tpl-parse-string (template)
  948. X  "Try to parse text at point as an instance of string-type TEMPLATE.
  949. X   Return a parse tree or nil."
  950. X                    ; Local Variables
  951. X  (let (tpl-name pattern-list pattern result success match start-col)
  952. X                    ; Body
  953. X    (setq tpl-name (tpl-token-name template))
  954. X    (setq pattern-list (tpl-token-value (tpl-line-to-token template)))
  955. X    (setq start-col (current-column))
  956. X    (setq result nil)
  957. X    (setq success t)
  958. X    (while (and success pattern-list)
  959. X      (setq pattern (car pattern-list))
  960. X      (setq pattern-list (cdr pattern-list))
  961. X      (setq match (tpl-parse-pattern
  962. X           pattern tpl-name start-col string-patterns))
  963. X      (if match
  964. X      (setq result (append result (list match)))
  965. X    ; else
  966. X    (setq success nil)
  967. X    ) ; if match
  968. X      ) ; while
  969. X    (if success
  970. X    result                ; return
  971. X      ; else
  972. X      nil                ; return
  973. X      ) ; if success
  974. X  ) ; let
  975. X) ; defun tpl-parse-string
  976. X
  977. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  978. X
  979. X(defun tpl-query-replace (from to)
  980. X  "Replace some instances after point matching FROM template with
  981. X    corresponding instances of TO.  As each match is found, the user
  982. X    must type a character saying what to do with it.  For directions,
  983. X    type \\[help-command] at that time."
  984. X                    ; Local Variables
  985. X  (let ()
  986. X                    ; Body
  987. X    (perform-replace-tpl from to t nil nil
  988. X             'tpl-search-forward
  989. X             'exchange-point-and-mark 'tpl-replace)
  990. X    ) ; let
  991. X  ) ; defun tpl-query-replace
  992. X
  993. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  994. X
  995. X(defun tpl-replace (from to)
  996. X  "Replace the instance of template FROM with a corresponding instance
  997. X    of template TO."
  998. X                    ; Local Variables
  999. X  (let (token-tree new start)
  1000. X                    ; Body
  1001. X    (setq start (point))
  1002. X    (message (concat "replace-tpl: Trying to match \"" from "\"..."))
  1003. X    (setq token-tree (tpl-parse-instance from))
  1004. X    ;(debug nil "token-tree" token-tree)
  1005. X    (message (concat "replace-tpl: Trying to construct \"" to "\"..."))
  1006. X    (setq new (tpl-token-to-line (tpl-replace-placeholders to token-tree)))
  1007. X    ;(debug nil "new tree" new)
  1008. X    (delete-region start (point))
  1009. X    (setq start (point))
  1010. X    (tpl-unscan new)
  1011. X    (set-mark start)
  1012. X    (message "replace-tpl: Done.")
  1013. X    ) ; let
  1014. X  ) ; defun tpl-replace
  1015. X
  1016. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1017. X
  1018. X(defun tpl-replace-placeholders (name tree)
  1019. X  "Replace placeholders in template NAME using values from TREE."
  1020. X                    ; Local Variables
  1021. X  (let (result template token-list token token-type current-indent match)
  1022. X                    ; Body
  1023. X    (setq result nil)
  1024. X    (setq template (tpl-find-template name))
  1025. X    (if (not (or
  1026. X          (equal tpl-sequence-type (tpl-token-type template))
  1027. X          (equal tpl-string-type (tpl-token-type template))))
  1028. X    (error (concat "tpl-replace-placeholders: "
  1029. X               "Target template must be SEQUENCE or STRING type"))
  1030. X      ) ; if
  1031. X    (setq token-list (tpl-token-value (tpl-line-to-token template)))
  1032. X    (while token-list
  1033. X      (setq token (car token-list))
  1034. X      (setq token-list (cdr token-list))
  1035. X      (setq token-type (tpl-token-name token))
  1036. X      ;(debug nil "token-type" token-type)
  1037. X      (if (or (equal tpl-placeholder-type token-type)
  1038. X          (equal tpl-optional-type token-type))
  1039. X      (progn
  1040. X        (setq match (tpl-get-match token tree current-indent))
  1041. X        (if match
  1042. X        (setq result (append result match))
  1043. X          ; else
  1044. X          (setq result (append result (list token)))
  1045. X          ) ; if match
  1046. X        ) ; progn
  1047. X    ; else
  1048. X    (progn
  1049. X      (if (equal tpl-indentation-type token-type)
  1050. X          (setq current-indent (tpl-token-value token))
  1051. X        ) ; if (equal tpl-indentation-type token-type)
  1052. X      (setq result (append result (list token)))
  1053. X      ) ; progn
  1054. X    ) ; if (equal tpl-placeholder-type token-type)
  1055. X      ) ; while token-list
  1056. X    (setq result (tpl-make-token t t result))
  1057. X    ; return
  1058. X    result
  1059. X    ) ; let
  1060. X  ) ; defun tpl-replace-placeholders
  1061. X
  1062. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1063. X
  1064. X(defun tpl-search-forward (template &optional bound forgiving count)
  1065. X  "Search forward from point for TEMPLATE (a name).
  1066. X    An optional second argument bounds the search; it is a buffer
  1067. X    position.  The match found must not extend beyond that position.
  1068. X    Optional third argument, if t, means if fail just return nil
  1069. X    (no error).  If not nil and not t, move to limit of search and
  1070. X    return nil.  Optional fourth argument is repeat count."
  1071. X                    ; Local Variables
  1072. X  (let (leading found occur gaveup start trial)
  1073. X                    ; Body
  1074. X    (setq start (point))
  1075. X    (if (not bound)
  1076. X    (setq bound (point-max))
  1077. X      )
  1078. X    (if (not count)
  1079. X    (setq count 1)
  1080. X      )
  1081. X    (setq occur 0)
  1082. X    (setq leading (tpl-leading-text template))
  1083. X    (if leading
  1084. X    (progn
  1085. X      (setq found nil)
  1086. X      (setq gaveup nil)
  1087. X      (while (and (not found) (not gaveup))
  1088. X        (if (search-forward leading bound t)
  1089. X        (progn
  1090. X          (search-backward leading)
  1091. X          (setq trial (point))
  1092. X          (setq found (tpl-looking-at template))
  1093. X          (if (and found
  1094. X               (<= (point) bound))
  1095. X              (progn
  1096. X            (setq occur (1+ occur))
  1097. X            (if (< occur count)
  1098. X                (setq found nil)
  1099. X              )
  1100. X            ) ; progn
  1101. X            ; else
  1102. X            (if found
  1103. X            (setq gaveup t)    ; Out of bounds---no more
  1104. X              ; else
  1105. X              (progn        ; Failed this time---try again
  1106. X            (goto-char trial)
  1107. X            (forward-line 1) 
  1108. X            ) ; progn
  1109. X              ) ; if found
  1110. X            ) ; if (and found...)
  1111. X          ) ; progn
  1112. X          ; else
  1113. X          (setq gaveup t)
  1114. X          ) ; if (search-forward...)
  1115. X        ) ; while
  1116. X      ) ; progn
  1117. X      ; else
  1118. X      (error "Cannot search for templates that start with a placeholder.")
  1119. X      ) ; if leading
  1120. X    (if (or gaveup (not found))
  1121. X    (if (not forgiving)
  1122. X        (progn
  1123. X          (goto-char bound)
  1124. X          (error "Could not find template.")
  1125. X          ) ; progn
  1126. X      ; else
  1127. X      (if (eq forgiving t)
  1128. X          (progn
  1129. X        (goto-char start)
  1130. X        ) ; progn
  1131. X        ; else
  1132. X        (progn
  1133. X          (goto-char bound)
  1134. X          ) ; progn
  1135. X        ) ; if (eq forgiving t)
  1136. X      ) ; if (not forgiving)
  1137. X      ) ; if (not found)
  1138. X    (if gaveup
  1139. X    (setq found nil)
  1140. X      ) ; if gaveup
  1141. X    ; return
  1142. X    found
  1143. X    ) ; let
  1144. X  ) ; defun tpl-search-forward
  1145. X
  1146. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1147. X
  1148. X(defun tpl-skip-over-whitespace ()
  1149. X  "Advance point past newlines and whitespace."
  1150. X                    ; Local Variables
  1151. X  (let (moving)
  1152. X                    ; Body
  1153. X    (setq moving t)
  1154. X    (while (and moving (not (eobp)))
  1155. X      (setq moving nil)
  1156. X      (if (eolp)
  1157. X      (progn
  1158. X        (setq moving t)
  1159. X        (forward-line 1)
  1160. X        ) ; progn
  1161. X    ) ; if
  1162. X      (if (looking-at tpl-pattern-whitespace)
  1163. X      (progn
  1164. X        (setq moving t)
  1165. X        (re-search-forward tpl-pattern-whitespace)
  1166. X        ) ; progn
  1167. X    ) ; if
  1168. X      ) ; while
  1169. X  ) ; let
  1170. X) ; defun tpl-skip-over-whitespace
  1171. X
  1172. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1173. X
  1174. X(defun tpl-token-to-line (tree)
  1175. X  "Convert TREE from token-format to line-format."
  1176. X                    ; Local Variables
  1177. X  (let (result line token-list token type name token-type save-indent)
  1178. X                    ; Body
  1179. X    (setq result nil)
  1180. X    (setq line nil)
  1181. X    (setq type (tpl-token-type tree))
  1182. X    (setq name (tpl-token-name tree))
  1183. X    (setq token-list (tpl-token-value tree))
  1184. X    (while token-list
  1185. X      (setq token (car token-list))
  1186. X      (setq token-list (cdr token-list))
  1187. X      (setq token-type (tpl-token-name token))
  1188. X      (cond
  1189. X       ((equal token-type tpl-indentation-type)
  1190. X    (progn
  1191. X      (setq save-indent (tpl-token-value token))
  1192. X      ) ; progn
  1193. X    ) ; tpl-indentation-type
  1194. X       ((equal token-type tpl-newline-type)
  1195. X    (progn
  1196. X      (setq result (append result (list (tpl-make-line save-indent line))))
  1197. X      (setq line nil)
  1198. X      ) ; progn
  1199. X    ) ; tpl-newline-type
  1200. X       (t
  1201. X    (progn
  1202. X      (setq line (append line (list token)))
  1203. X      ) ; progn
  1204. X    ) ; t
  1205. X       ) ; cond
  1206. X      ) ; while token-list
  1207. X    (setq result (append result (list (tpl-make-line save-indent line))))
  1208. X    (setq result (tpl-make-token type name result))
  1209. X    ; return
  1210. X    result
  1211. X    ) ; let
  1212. X  ) ; defun tpl-token-to-line
  1213. X
  1214. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1215. X
  1216. X;;; end of tplparse.el
  1217. SHAR_EOF
  1218. if test 35827 -ne "`wc -c < 'tplparse.el'`"
  1219. then
  1220.     echo shar: "error transmitting 'tplparse.el'" '(should have been 35827 characters)'
  1221. fi
  1222. fi
  1223. echo shar: "extracting 'tplscan.el'" '(12570 characters)'
  1224. if test -f 'tplscan.el'
  1225. then
  1226.     echo shar: "will not over-write existing file 'tplscan.el'"
  1227. else
  1228. sed 's/^X//' << \SHAR_EOF > 'tplscan.el'
  1229. X;;; tplscan.el -- Scanner for template package
  1230. X;;; Copyright (C) 1987 Mark A. Ardis.
  1231. X
  1232. X(require 'tplvars)
  1233. X
  1234. X(provide 'tplscan)
  1235. X
  1236. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1237. X;;; All global variables are in "tplvars".
  1238. X
  1239. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1240. X
  1241. X(defun tpl-make-pattern (pn pv)
  1242. X  "Constructor for lexical patterns."
  1243. X  (list (list 'name pn) (list 'value pv))
  1244. X  ) ; defun tpl-make-pattern
  1245. X
  1246. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1247. X
  1248. X(defun tpl-pattern-name (p)
  1249. X  "Selector for name field of lexical patterns."
  1250. X  (car (cdr (assq 'name p)))
  1251. X  ) ; defun tpl-pattern-name
  1252. X
  1253. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1254. X
  1255. X(defun tpl-pattern-value (p)
  1256. X  "Selector for value field of lexical patterns."
  1257. X  (car (cdr (assq 'value p)))
  1258. X  ) ; defun tpl-pattern-value
  1259. X
  1260. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1261. X
  1262. X(defun tpl-make-token (tt tn tv)
  1263. X  "Constructor for tokens."
  1264. X  (list (list 'type tt) (list 'name tn) (list 'value tv))
  1265. X  ) ; defun tpl-make-token
  1266. X
  1267. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1268. X
  1269. X(defun tpl-token-type (token)
  1270. X  "Selector for type field of tokens."
  1271. X  (car (cdr (assq 'type token)))
  1272. X  ) ; defun tpl-token-type
  1273. X
  1274. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1275. X
  1276. X(defun tpl-token-name (token)
  1277. X  "Selector for name field of tokens."
  1278. X  (car (cdr (assq 'name token)))
  1279. X  ) ; defun tpl-token-name
  1280. X
  1281. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1282. X
  1283. X(defun tpl-token-value (token)
  1284. X  "Selector for value field of tokens."
  1285. X  (car (cdr (assq 'value token)))
  1286. X  ) ; defun tpl-token-value
  1287. X
  1288. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1289. X
  1290. X(defun tpl-make-line (indent-level token-list)
  1291. X  "Constructor for lines."
  1292. X  (list (list 'indent indent-level) (list 'tokens token-list))
  1293. X  ) ; defun tpl-make-line
  1294. X
  1295. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1296. X
  1297. X(defun tpl-line-indent (line)
  1298. X  "Selector for indentation field of lines."
  1299. X  (car (cdr (assq 'indent line)))
  1300. X  ) ; defun tpl-line-indent
  1301. X
  1302. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1303. X
  1304. X(defun tpl-line-tokens (line)
  1305. X  "Selector for token-list field of lines."
  1306. X  (car (cdr (assq 'tokens line)))
  1307. X  ) ; defun tpl-line-tokens
  1308. X
  1309. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1310. X
  1311. X(defun tpl-scan-region (start stop pattern-list)
  1312. X  "Scan the text between START and STOP using PATTERN-LIST for tokens.
  1313. X   Return an indented line-list of tokens."
  1314. X                    ; Local Variables
  1315. X  (let (start-col last-col this-col indent-level last-indent
  1316. X          line line-list more)
  1317. X                    ; Body
  1318. X    (goto-char start)
  1319. X    (setq start-col (current-column))
  1320. X    (setq line-list nil)
  1321. X    (save-restriction
  1322. X      (narrow-to-region start stop)
  1323. X      (and (boundp 'template-scan-hook)
  1324. X       template-scan-hook
  1325. X       (funcall template-scan-hook))
  1326. X      (if (eobp)
  1327. X      (setq more nil)
  1328. X    (setq more t)
  1329. X    ) ; if (eobp)
  1330. X      (while more
  1331. X                    ; Scan a line
  1332. X    (back-to-indentation)
  1333. X    (setq line (tpl-scan-line start-col pattern-list))
  1334. X    (setq line-list (append line-list (list line)))
  1335. X                    ; Advance to next line
  1336. X    (if (not (eobp))
  1337. X        (forward-char)
  1338. X      (setq more nil)
  1339. X      ) ; if (not (eobp))
  1340. X    ) ; while more
  1341. X      ) ; save-restriction
  1342. X                    ; return
  1343. X    line-list
  1344. X    ) ; let
  1345. X  ) ; defun tpl-scan-region
  1346. X
  1347. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1348. X
  1349. X(defun tpl-scan-line (start-col pattern-list)
  1350. X  "Scan a line of text, returning an indentation-line of tokens.
  1351. X   START-COL is the origin column for a region.
  1352. X   PATTERN-LIST is the list of tokens to scan for."
  1353. X                    ; Local Variables
  1354. X  (let (this-col indent-level line)
  1355. X                    ; Body
  1356. X    (if tpl-literal-whitespace
  1357. X    (progn
  1358. X      (beginning-of-line nil)
  1359. X      (setq line (tpl-make-line 0 (tpl-scan-token-list pattern-list)))
  1360. X      ) ; progn
  1361. X      ; else
  1362. X      (progn
  1363. X    (back-to-indentation)
  1364. X    (setq this-col (current-column))
  1365. X    (cond
  1366. X     ((>= this-col comment-column)
  1367. X      (progn
  1368. X        (setq indent-level tpl-comment-level)
  1369. X        ) ; progn
  1370. X      ) ; comment
  1371. X     ((<= this-col start-col)
  1372. X      (progn
  1373. X        (setq indent-level 0)
  1374. X        ) ; progn
  1375. X      ) ; too small
  1376. X     (t
  1377. X      (progn
  1378. X        (setq indent-level (- this-col start-col))
  1379. X        ) ; progn
  1380. X      ) ; t
  1381. X     ) ; cond
  1382. X                    ; Scan tokens and make into a line
  1383. X    (setq line (tpl-make-line indent-level
  1384. X                  (tpl-scan-token-list pattern-list)))
  1385. X    ) ; progn
  1386. X      ) ; if tpl-literal-whitespace
  1387. X                    ; return
  1388. X    line
  1389. X    ) ; let
  1390. X  ) ; defun tpl-scan-line
  1391. X
  1392. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1393. X
  1394. X(defun tpl-scan-token (pattern-list)
  1395. X  "Scan the text at point and return a token.
  1396. X   PATTERN-LIST is the list of tokens to scan for."
  1397. X                    ; Local Variables
  1398. X  (let (pattern pn pv token found start)
  1399. X                    ; Body
  1400. X    (setq found nil)
  1401. X    (while (and pattern-list (not found))
  1402. X      (setq pattern (car pattern-list))
  1403. X      (setq pattern-list (cdr pattern-list))
  1404. X      (setq pn (tpl-pattern-name pattern))
  1405. X      (setq pv (tpl-pattern-value pattern))
  1406. X      (if (looking-at pv)
  1407. X      (setq found t)
  1408. X    ) ; if (looking-at pattern)
  1409. X      ) ; while (and pattern-list (not found))
  1410. X    (if (not found)
  1411. X    (error "Unable to scan text.")
  1412. X      ) ; if (not found)
  1413. X    (setq start (point))
  1414. X    (re-search-forward pv)
  1415. X    (setq token (tpl-make-token tpl-terminal-type pn
  1416. X                (buffer-substring start (point))))
  1417. X    token                ; return
  1418. X    ) ; let
  1419. X  ) ; defun tpl-scan-token
  1420. X
  1421. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1422. X
  1423. X(defun tpl-scan-token-list (pattern-list)
  1424. X  "Scan the current line and return a list of tokens.
  1425. X   PATTERN-LIST is the list of tokens to scan for."
  1426. X                    ; Local Variables
  1427. X  (let (save-list token token-list)
  1428. X                    ; Body
  1429. X    (setq token-list nil)
  1430. X    (setq save-list pattern-list)
  1431. X    (while (not (eolp))
  1432. X      (setq pattern-list save-list)
  1433. X      (setq token (tpl-scan-token pattern-list))
  1434. X      (setq token-list (append token-list (list token)))
  1435. X      ) ; while (not (eolp))
  1436. X                    ; return
  1437. X    token-list
  1438. X    ) ; let
  1439. X  ) ; defun tpl-scan-token-list
  1440. X
  1441. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1442. X
  1443. X(defun tpl-scan-template ()
  1444. X  "Scan the template at point and return its tree value."
  1445. X                    ; Local Variables
  1446. X  (let (start template-name template-type token-list tree save-patterns)
  1447. X                    ; Body
  1448. X    (re-search-forward tpl-begin-template-definition)
  1449. X    (re-search-forward tpl-pattern-whitespace)
  1450. X    (setq start (point))
  1451. X    (re-search-forward tpl-pattern-symbol)
  1452. X    (setq template-name (buffer-substring start (point)))
  1453. X    (re-search-forward tpl-pattern-whitespace)
  1454. X    (setq start (point))
  1455. X    (re-search-forward tpl-pattern-word)
  1456. X    (setq template-type (buffer-substring start (point)))
  1457. X    (re-search-forward tpl-begin-template-body)
  1458. X    (beginning-of-line 2)
  1459. X    (setq start (point))
  1460. X    (re-search-forward tpl-end-template-body)
  1461. X    (end-of-line 0)
  1462. X    (if (or (equal template-type tpl-lexical-type)
  1463. X        (equal template-type tpl-function-type))
  1464. X    (setq token-list (buffer-substring start (point)))
  1465. X      ; else
  1466. X      (if (equal template-type tpl-string-type)
  1467. X      (setq token-list (tpl-scan-region start (point) string-patterns))
  1468. X    ; else
  1469. X    (setq token-list (tpl-scan-region start (point) lex-patterns))
  1470. X    ) ; if (equal template-type tpl-string-type)
  1471. X      ) ; if (or ...)
  1472. X    (setq tree (tpl-make-token template-type template-name token-list))
  1473. X                    ; return
  1474. X    tree
  1475. X    ) ; let
  1476. X  ) ; defun tpl-scan-template
  1477. X
  1478. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1479. X
  1480. X(defun tpl-scan-placeholder ()
  1481. X  "Scan the placeholder at point and return its tree value."
  1482. X                    ; Local Variables
  1483. X  (let (save start placeholder-type placeholder-name token-type)
  1484. X                    ; Body
  1485. X    (setq save (point))
  1486. X    (re-search-forward tpl-begin-placeholder)
  1487. X    (if (looking-at tpl-pattern-optional)
  1488. X    (progn
  1489. X      (setq token-type tpl-optional-type)
  1490. X      (re-search-forward tpl-pattern-optional)
  1491. X      ) ; progn
  1492. X      ; else
  1493. X      (progn
  1494. X    (setq token-type tpl-placeholder-type)
  1495. X    ) ; progn
  1496. X      ) ; if (looking-at tpl-pattern-optional)
  1497. X    (setq start (point))
  1498. X    (if (looking-at tpl-destination-symbol)
  1499. X    (forward-char (length tpl-destination-symbol))
  1500. X      (re-search-forward tpl-pattern-symbol)
  1501. X      ) ; if
  1502. X    (setq placeholder-type (buffer-substring start (point)))
  1503. X    (if (looking-at tpl-sep-placeholder)
  1504. X    (progn
  1505. X      (re-search-forward tpl-sep-placeholder)
  1506. X      (setq start (point))
  1507. X      (re-search-forward tpl-pattern-symbol)
  1508. X      (setq placeholder-name (buffer-substring start (point)))
  1509. X      ) ; progn
  1510. X      ; else
  1511. X      (progn
  1512. X    (setq placeholder-name nil)
  1513. X    ) ; progn
  1514. X      ) ; if (looking-at tpl-sep-placeholder)
  1515. X    (setq placeholder (tpl-make-token
  1516. X               token-type
  1517. X               placeholder-type
  1518. X               placeholder-name))
  1519. X    (goto-char save)
  1520. X                    ; return
  1521. X    placeholder
  1522. X    ) ; let
  1523. X  ) ; defun tpl-scan-placeholder
  1524. X
  1525. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1526. X
  1527. X(defun tpl-unscan (token &optional column)
  1528. X  "Insert at point the values of tokens in the tree rooted by TOKEN.
  1529. X     Optional second argument COLUMN specifies where to indent rigidly.
  1530. X     Default is the current column."
  1531. X                    ; Local Variables
  1532. X  (let (begin-template start-column token-list line-list line save-hook)
  1533. X                    ; Body
  1534. X                    ; Save auto-fill-hook and reset
  1535. X    (setq save-hook auto-fill-hook)
  1536. X    (if (not tpl-fill-while-unscanning)
  1537. X    (setq auto-fill-hook nil)
  1538. X      ) ; if
  1539. X                    ; Unscan template
  1540. X    (setq begin-template (point))
  1541. X    (if column
  1542. X    (setq start-column column)
  1543. X      ; else
  1544. X      (setq start-column (current-column))
  1545. X      ) ; if column
  1546. X    (setq line-list (tpl-token-value token))
  1547. X    (while line-list
  1548. X      (setq line (car line-list))
  1549. X      (setq line-list (cdr line-list))
  1550. X      (if (= tpl-comment-level (tpl-line-indent line))
  1551. X      (indent-to comment-column)
  1552. X    ; else
  1553. X    (indent-to (+ start-column (tpl-line-indent line)))
  1554. X    ) ; if
  1555. X      (setq token-list (tpl-line-tokens line))
  1556. X      (while token-list
  1557. X    (setq token (car token-list))
  1558. X    (setq token-list (cdr token-list))
  1559. X    ;(debug "tpl-unscan token:" token)
  1560. X    (insert-before-markers (tpl-token-value token))
  1561. X    ) ; while token-list
  1562. X      (if line-list
  1563. X      (newline)
  1564. X    ) ; if line-list
  1565. X      ) ; while line-list
  1566. X    (if (and (boundp 'template-unscan-hook)
  1567. X         template-unscan-hook)
  1568. X    (funcall template-unscan-hook begin-template (point) start-column)
  1569. X      ) ; if
  1570. X                    ; Reset auto-fill-hook
  1571. X    (setq auto-fill-hook save-hook)
  1572. X    ) ; let
  1573. X  ) ; defun tpl-unscan
  1574. X
  1575. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1576. X
  1577. X(defun tpl-fix-syntax (string)
  1578. X  "Change any syntax entries in STRING from (word or symbol or quote)
  1579. X   to punctuation."
  1580. X                    ; Local Variables
  1581. X  (let (char)
  1582. X                    ; Body
  1583. X    (while (> (length string) 0)
  1584. X      (setq char (string-to-char string))
  1585. X      (setq string (substring string 1))
  1586. X      (if (or (equal (char-syntax char) ? )
  1587. X          (equal (char-syntax char) ?_)
  1588. X          (equal (char-syntax char) ?'))
  1589. X      (modify-syntax-entry char ".   ")
  1590. X    ) ; if
  1591. X      ) ; while
  1592. X    ) ; let
  1593. X  ) ; defun tpl-fix-syntax
  1594. X
  1595. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1596. X
  1597. X(defun tpl-initialize-scan ()
  1598. X  "Initialize environment for scan."
  1599. X                    ; Local Variables
  1600. X  (let ()
  1601. X                    ; Body
  1602. X                    ; Make all characters non-symbols
  1603. X    (tpl-fix-syntax tpl-begin-placeholder)
  1604. X    (tpl-fix-syntax tpl-end-placeholder)
  1605. X    (tpl-fix-syntax tpl-sep-placeholder)
  1606. X    (tpl-fix-syntax tpl-pattern-optional)
  1607. X                    ; Build composite patterns
  1608. X    (setq tpl-begin-optional (concat tpl-begin-placeholder
  1609. X                     tpl-pattern-optional))
  1610. X    (setq tpl-destination-placeholder (concat tpl-begin-placeholder
  1611. X                          tpl-destination-symbol
  1612. X                          tpl-end-placeholder))
  1613. X    (setq tpl-pattern-placeholder (concat tpl-begin-placeholder
  1614. X                      "\\(" tpl-pattern-optional "\\)?"
  1615. X                      tpl-pattern-symbol
  1616. X                      "\\(" tpl-sep-placeholder
  1617. X                      tpl-pattern-symbol "\\)?"
  1618. X                      tpl-end-placeholder))
  1619. X                    ; Build lexical patterns
  1620. X    (setq lex-patterns
  1621. X      (list
  1622. X       (tpl-make-pattern tpl-placeholder-type tpl-pattern-placeholder)
  1623. X       (tpl-make-pattern tpl-whitespace-type tpl-pattern-whitespace)
  1624. X       (tpl-make-pattern tpl-word-type tpl-pattern-word)
  1625. X       (tpl-make-pattern tpl-punctuation-type tpl-pattern-punctuation)
  1626. X       (tpl-make-pattern tpl-other-type tpl-pattern-other)
  1627. X       ))
  1628. X    (setq string-patterns
  1629. X      (list
  1630. X       (tpl-make-pattern tpl-string-type tpl-pattern-string)
  1631. X       ))
  1632. X    (setq tpl-newline-token
  1633. X      (tpl-make-token tpl-terminal-type tpl-newline-type nil))
  1634. X    ) ; let
  1635. X  ) ; defun tpl-initialize-scan
  1636. X
  1637. X;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1638. X
  1639. X;;; end of tplscan.el
  1640. SHAR_EOF
  1641. if test 12570 -ne "`wc -c < 'tplscan.el'`"
  1642. then
  1643.     echo shar: "error transmitting 'tplscan.el'" '(should have been 12570 characters)'
  1644. fi
  1645. fi
  1646. exit 0
  1647. #    End of shell archive
  1648.  
  1649.  
  1650.